Option Explicit
If ThisApplication.Classifiers.Count <> 0 Then
    Call OutClassifList()
Else
    MsgBox "В данной конфигурации классификаторы отсутствуют."
End If


'=====================================================================
' Вывести и отформатировать в Excel дерево классификаторов 
'=====================================================================
Sub OutClassifList()
    On Error Resume Next
    Err = 0    

    Dim ExcelApp, WrkBook, Classifs, CurrentClsNode, List, ListName, Progress, nStep, i

    ' Использовать ProgressDlg для отображения хода операции
    Set Progress = ThisApplication.Dialogs.ProgressDlg
    'Целочисленным делением определяем примерный шаг прогресса
    nStep = 100 \ (ThisApplication.Classifiers.Count + 2)
    Progress.Start
    Progress.Position = 0 
    Progress.Text = "Вывод в Excel таблицы классификаторов..."

    ' Запуск приложения MSExcel
    Set ExcelApp = CreateObject("Excel.Application")
    If Err <> 0 Then 'ошибка открытия приложения Excel
        MsgBox "Невозможно открыть приложение Excel.",  vbInformation, "Ошибка MS Excel" 
        Err = 0
        'Закрыть диалог индикатора выполнения
        Progress.Position = 100 ' Установка текущего процента прогресса
        Progress.Stop
        Progress.Position = 0
        Set Progress = Nothing
        Exit Sub
    End If
    ' Установка текущего процента прогресса
    Progress.Position = Progress.Position + nStep  
                    
    ' Добавить новую книгу Excel
    Set WrkBook = ExcelApp.Workbooks.Add
    
    ' Вывести в MSExcel все значения классификаторов
    Set Classifs = ThisApplication.Classifiers ' получить корневые классификаторы
    'Перебор по корневым элементам иерархии классификаторов
    For i = 1 To Classifs.Count 
        'текущий узел дерева классификаторов
        Set CurrentClsNode = Classifs(i - 1)
    
        'добавить лист в рабочую книгу Excel за предыдущим
        If i > 1 Then
            Set List = WrkBook.Sheets.Add(, WrkBook.Sheets.Item(i-1)) 
            'добавить первый лист в рабочую книгу
        Else
            Set List = WrkBook.Sheets.Add 
        End If

        'присвоить листу имя текущего классификатора (обрезав до 30 символов)
        ListName = i & ") " & Left(CurrentClsNode.Description, 30)
        List.Name = ListName 
        If Err <> 0 Then 
            'ошибка переименования листа Excel. Он не выносит спецсимволы 
            MsgBox "Невозможно присвоить листу имя """ & ListName & """.", _
                vbInformation, "Ошибка MS Excel" 
            Err = 0
            ' Установка текущего процента прогресса
            Progress.Position = 100 
            'Закрыть диалог индикатора выполнения
            Progress.Stop
            Progress.Position = 0
            Set Progress = Nothing
            ' Показать окно MSExcel - то, что уже сделано
            WrkBook.Sheets(1).Activate
            ExcelApp.Application.Visible = TRUE
            Set List = Nothing
            Set WrkBook = Nothing
            Set ExcelApp = Nothing
            Exit Sub
        End If
        'В первой ячейке сохранить полное наименование классификатора
        List.Cells(1) = CurrentClsNode.Description

         'Развернуть на листе дочерние значения текущего классификатора
          Call ExpandClassifNode(ExcelApp, List, CurrentClsNode, 1, 1)

        'Отформатировать выведенную таблицу 
        List.Cells(1).Font.Size = 14
        List.Cells(1).Font.Bold = True
        List.Columns.AutoFit
        ' Установка текущего процента прогресса
        Progress.Position = Progress.Position + nStep 
    Next
        
    ' Показать окно MSExcel и завершить работу - обнулить объектные переменные
    WrkBook.Sheets(1).Activate
    ExcelApp.Application.Visible = TRUE
    Set List = Nothing
    Set WrkBook = Nothing
    Set ExcelApp = Nothing

    ' Установка текущего процента прогресса
    Progress.Position = 100 
    'Закрыть диалог индикатора выполнения
    Progress.Stop
    Progress.Position = 0
    Set Progress = Nothing
End Sub
'======================================================================

'Рекурсивным вызовом разобрать текущую ветку классификатора
'Аргумент StartRow передается по ссылке - его значение (текущая 
'строка)будет меняться при рекурсии
Sub ExpandClassifNode(ExcelApp, ExcelList, ParentClsNode, ByRef StartRow, StartCol)
        
        Dim SubCls, row, col, count
        
        'Запомнить строку, с которой начали заполнение таблицы
        row = StartRow
        'Получить указатель на коллекцию дочерних элементов переданного нам классификатора
        Set SubCls = ParentClsNode.Classifiers
        'Вывести наименования дочерних элементов в ячейки соседнего (справа) столбца
        For count = 1 To SubCls.Count 
                With ExcelList
                        StartRow = StartRow + 1
                        .Cells(StartRow, StartCol+1) = SubCls(count-1).Description
                        'Если у дочернего классификатора есть "внучатые", разобрать и их - 
                        'для этого применяем рекурсивный вызов функции
                        If SubCls(count-1).Classifiers.Count <> 0 Then
                              Call ExpandClassifNode(ExcelApp, ExcelList, SubCls(count-1),_
                                                      StartRow, StartCol+1)                    
                        End If
                End With
        Next
        'Нарисовать границы вокруг выведенной таблицы
        Call    DrawCellsBorder(ExcelApp, row, StartRow, StartCol, StartCol+1)
        Set SubCls = Nothing
End Sub

'======================================================================

'Нарисовать рамку вокруг прямоугольной области, заданной граничными строками и столбцами
Sub DrawCellsBorder(ExcelApp, StartRow, EndRow, FirstCol, LastCol)
   Dim i
   'Выделить прямоугольную область, задав левую верхнюю и правую нижнюю ячейки
       ExcelApp.Range(ExcelApp.Cells(StartRow, FirstCol),_
                        ExcelApp.Cells(EndRow, LastCol)).Select
   'Нарисовать границу вокруг выделения
       For i = 7 To 10
             With ExcelApp.Selection.Borders(i) 'xlEdgeLeft
                .LineStyle = 1 'xlContinuous
                .Weight = 2 'xlThin
                .ColorIndex = -4105 'xlAutomatic
            End With
   Next
End Sub
'======================================================================